25  Многоклассовая классификация

Многоклассовая классификация может использоваться для определения автора, жанра, тематики или эмоциональной тональности текста.

library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)

25.1 Данные

https://www.kaggle.com/datasets/mikhailklemin/kinopoisks-movies-reviews

path_neg <- list.files("../files/kinopoisk/neg", full.names = TRUE)
path_pos <- list.files("../files/kinopoisk/pos", full.names = TRUE)
path_neu <- list.files("../files/kinopoisk/neu", full.names = TRUE)

# для ускорения вычислений на занятии
path_sel <- c(path_neg[1:1000], path_pos[1:1000], path_neu[1:1000])

read_review <- function(path) {
  tibble(review = read_lines(path) |>
           str_c(collapse = " "),
         sentiment = str_extract(path, "pos|neg|neu"))
}

reviews <- map_df(path_sel, read_review)
reviews

25.2 Разведывательный анализ

В нашем датасете есть несколько очень коротких рецензий. Негативные рецензии в целом длиннее позитивных и нейтральных.

reviews |> 
  mutate(n_words = str_count(review, " ") + 1) |> 
  ggplot(aes(n_words, fill = sentiment)) +
  geom_histogram(bins = 100) +
  xlab(NULL) +
  ylab(NULL) +
  scale_fill_viridis_d() + 
  theme_light()

Посмотрим на число уникальных токенов в каждой из категорий.

reviews_tokens <- reviews |> 
  mutate(id = row_number(), .before = sentiment) |> 
  unnest_tokens(token, review) 

reviews_tokens |> 
  group_by(sentiment) |> 
  summarise(n = n_distinct(token))

Большая часть слов встречается очень редко.

reviews_tokens |> 
  count(sentiment, token) |> 
  ggplot(aes(n, fill = sentiment)) +
  geom_histogram(show.legend = FALSE, bins = 1000) +
  coord_cartesian(xlim = c(NA, 2500), ylim = c(NA, 2500)) +
  theme_light() +
  scale_fill_viridis_d()

Здесь можно добавить пример из https://juliasilge.com/blog/nber-papers/.

25.3 Обучающая и тестовая выборки

set.seed(09032025)
data_split <- reviews |> 
  mutate(sentiment = as.factor(sentiment)) |> 
  initial_split( strata = sentiment)
data_train <- training(data_split) 
data_test <- testing(data_split)

# folds
set.seed(09032025)
folds <- vfold_cv(data_train, strata = sentiment, v = 5)
folds

25.4 Рецепт для препроцессинга

library(stopwords)
stopwords_ru <- c(
  stopwords("ru", source = "snowball"),
  stopwords("ru", source = "marimo"),
  stopwords("ru", source = "nltk"))

# уберем повторы и упорядочим по алфавиту
stopwords_ru <- sort(unique(stopwords_ru))
length(stopwords_ru)

[1] 380

Подробнее о рецепте см. https://smltar.com/mlregression#firstregression

tfidf_rec <- recipe(sentiment ~ review, data = data_train) |>
  step_mutate(review = stringr::str_remove_all(review, "\\d+")) |> 
  step_mutate(review = stringr::str_remove_all(review, "[A-Za-z]")) |> 
  step_tokenize(review) |>
  step_stopwords(review, custom_stopword_source = stopwords_ru) |>
  step_stem(review, options = list(language = "russian")) |>
  step_tokenfilter(all_predictors(), 
                   max_tokens = 1000, 
                   min_times = 2) |> 
  step_tfidf(review) |> 
  step_zv(all_predictors()) |> 
  step_normalize(all_predictors())

tfidf_rec

── Recipe ──────────────────────────────────────────────────────────────────────

── Inputs 

Number of variables by role

outcome:   1
predictor: 1

── Operations 

• Variable mutation for: stringr::str_remove_all(review, "\\d+")

• Variable mutation for: stringr::str_remove_all(review, "[A-Za-z]")

• Tokenization for: review

• Stop word removal for: review

• Stemming for: review

• Text filtering for: all_predictors()

• Term frequency-inverse document frequency with: review

• Zero variance filter on: all_predictors()

• Centering and scaling for: all_predictors()

25.5 Результат препроцессинга

prep_train_tfidf <- tfidf_rec |>
  prep(data_train) 

tidy(prep_train_tfidf)

bake_train_tfidf <- prep_train_tfidf |> 
  bake(new_data = NULL)

bake_train_tfidf

25.6 Первая модель: регрессия с регуляризацией

Когда мы работаем с текстовыми данными и используем большое число признаков для классификации, важно избегать алгоритмов, которые плохо работают с высоким числом измерений (например, k-NN). Вместо этого лучше использовать более эффективные алгоритмы, такие как линейные модели с регуляризацией.

Для задач классификации применяется логистическая регрессия, которая неплохо справляется с разреженными данными благодаря L1-регуляризации (Lasso) или L2-регуляризации (Ridge). В частности, лассо-регуляризация позволяет обнулять незначимые признаки, исключая их тем самым из модели.

Поскольку в нашем датасете три класса, то мы применим многоклассовую логистическую регрессию.

lasso_spec <- multinom_reg(penalty = tune(), mixture = 1) |> 
  set_mode("classification") |> 
  set_engine("glmnet")

lasso_param <- extract_parameter_set_dials(lasso_spec)
  
lasso_grid <- lasso_param |> 
  grid_regular(levels = 3)

lasso_grid

lasso_wflow <- workflow() |> 
  add_model(lasso_spec) |> 
  add_recipe(tfidf_rec)

lasso_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: multinom_reg()

── Preprocessor ────────────────────────────────────────────────────────────────
9 Recipe Steps

• step_mutate()
• step_mutate()
• step_tokenize()
• step_stopwords()
• step_stem()
• step_tokenfilter()
• step_tfidf()
• step_zv()
• step_normalize()

── Model ───────────────────────────────────────────────────────────────────────
Multinomial Regression Model Specification (classification)

Main Arguments:
  penalty = tune()
  mixture = 1

Computational engine: glmnet 

Здесь придется немного (или много) подождать.

library(tictoc)
library(future)

plan(multisession, workers = 5)

tic()
set.seed(10032025)
lasso_tune <- lasso_wflow |> 
  tune_grid(
    resamples = folds, 
    grid = lasso_grid,
    metrics = metric_set(accuracy, roc_auc),
    control = control_resamples(save_pred = TRUE, save_workflow = TRUE)
  )

lasso_tune 

toc()
# 61.116 sec elapsed
plan(sequential)

autoplot(lasso_tune)

Наша модель достигла не очень высокой точности: она работает лишь немногим лучше нулевой, и хуже всего предсказывает нейтральные отзывы.

collect_predictions(lasso_tune) |> 
  roc_curve(truth = sentiment, .pred_neg:.pred_pos)  |> 
  ggplot(aes(1 - specificity, sensitivity, color = .level)) +
  geom_abline(slope = 1, color = "gray50", lty = 2, alpha = 0.8) +
  geom_path(linewidth = 1.5, alpha = 0.7) +
  labs(color = NULL) +
  coord_fixed() +
  theme_light()

25.7 SVM

svm_spec <- svm_linear(cost = tune()) |> 
  set_mode("classification") |> 
  set_engine("LiblineaR")

svm_param <- extract_parameter_set_dials(svm_spec)

svm_grid <- svm_param |> 
  grid_regular(levels = 3)

svm_grid

25.8 Random forest

rf_spec <- rand_forest(
  trees = tune()) |>        
  set_mode("classification") |> 
  set_engine("ranger")

rf_spec

Random Forest Model Specification (classification)

Main Arguments:
  trees = tune()

Computational engine: ranger 

rf_param <- extract_parameter_set_dials(rf_spec)

rf_grid <- rf_param |> 
  grid_regular(levels = 2)

rf_grid

25.9 Workflow_set

wflow_set <- workflow_set(  
  preproc = list(tfidf = tfidf_rec),  
  models = list(svm = svm_spec,
                rf = rf_spec),  
  cross = TRUE
)


wflow_set

wflow_set_final <- wflow_set |> 
  option_add(grid = svm_grid, id = "tfidf_svm") |> 
  option_add(grid = rf_grid, id = "tfidf_rf")

Снова немного подождем.

plan(multisession, workers = 5)

set.seed(09022025)
tic()
wflow_set_fit <- 
  workflow_map(
    wflow_set_final, 
    verbose = TRUE, 
    metrics = metric_set(accuracy),
    resamples = folds,
    control = control_resamples(save_pred = TRUE),
    fn = "tune_grid"
  )
toc()

plan(sequential)
# i 1 of 2 tuning:     tfidf_svm
# ✔ 1 of 2 tuning:     tfidf_svm (23.5s)
# i 2 of 2 tuning:     tfidf_rf
# ✔ 2 of 2 tuning:     tfidf_rf (27.5s)
# 51.832 sec elapsed

25.10 Объединение воркфлоу

wflow_set_final <- wflow_set_fit |> 
  bind_rows(as_workflow_set(lasso_tfidf = lasso_tune))

autoplot(wflow_set_final, metric = "accuracy") + 
  theme_light() +
  theme(legend.position = "none") +
  geom_text(aes(y = (mean - 2*std_err), label = wflow_id), angle = 90, hjust = 1) +
  lims(y = c(-0.1, 1))

25.11 Выбор модели и окончательная настройка

rank_results(wflow_set_final, rank_metric = "accuracy")

Warning: Some metrics were not used in all workflows: roc_auc
Some metrics were not used in all workflows: roc_auc

autoplot(wflow_set_fit, id = "tfidf_rf") +
  theme_light()

best_results <- 
   wflow_set_final |> 
   extract_workflow_set_result("tfidf_rf") |> 
   select_best(metric = "accuracy")

best_results

rf_test_results <- 
   wflow_set_final |> 
   extract_workflow("tfidf_rf") |> 
   finalize_workflow(best_results) |> 
   last_fit(split = data_split)

rf_test_results

25.12 Оценка

collect_metrics(rf_test_results)

rf_test_results |> 
  collect_predictions() |>
  conf_mat(truth = sentiment, estimate = .pred_class) |> 
  autoplot(type = "heatmap") +
  scale_fill_gradient(low = "white", high = "#233857") +
  theme(panel.grid.major = element_line(colour = "#233857"),
        axis.text = element_text(color = "#233857"),
        axis.title = element_text(color = "#233857"),
        plot.title = element_text(color = "#233857"),
        axis.text.x = element_text(angle = 90))

На очень разреженных данных мы смогли немного улучшить предсказания, однако другой способ может заключаться в том, чтобы снизить размерность за счет PCA или эмбеддингов. Про эмбеддинги пойдет речь дальше, а здесь рассмотрим пример препроцессинга с использованием PCA. Это не всегда дает хороший результат.

25.13 P.S. PCA-рецепт

pca_rec <- recipe(sentiment ~ review, data = data_train) |>
  step_mutate(review = stringr::str_remove_all(review, "\\d+")) |> 
  step_mutate(review = stringr::str_remove_all(review, "[A-Za-z]")) |> 
  step_tokenize(review) |>
  step_stopwords(review, custom_stopword_source = stopwords_ru) |>
  step_stem(review, options = list(language = "russian")) |>
  step_tokenfilter(all_predictors(), 
                   max_tokens = 1000, 
                   min_times = 2) |> 
  step_tfidf(review) |> 
  step_zv(all_predictors()) |> 
  step_normalize(all_predictors()) |> 
  step_pca(all_predictors(), num_comp = 100)

pca_rec

── Recipe ──────────────────────────────────────────────────────────────────────

── Inputs 

Number of variables by role

outcome:   1
predictor: 1

── Operations 

• Variable mutation for: stringr::str_remove_all(review, "\\d+")

• Variable mutation for: stringr::str_remove_all(review, "[A-Za-z]")

• Tokenization for: review

• Stop word removal for: review

• Stemming for: review

• Text filtering for: all_predictors()

• Term frequency-inverse document frequency with: review

• Zero variance filter on: all_predictors()

• Centering and scaling for: all_predictors()

• PCA extraction with: all_predictors()

prep_train_pca <- pca_rec |>
  prep(data_train) 

tidy(prep_train_pca)

Как можно видеть, количество признаков уменьшилось в 10 раз.

bake_train_pca <- prep_train_pca |> 
  bake(new_data = NULL)

bake_train_pca

rf_pca_wflow <- workflow() |> 
  add_model(rf_spec) |> 
  add_recipe(pca_rec)

rf_pca_wflow

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: rand_forest()

── Preprocessor ────────────────────────────────────────────────────────────────
10 Recipe Steps

• step_mutate()
• step_mutate()
• step_tokenize()
• step_stopwords()
• step_stem()
• step_tokenfilter()
• step_tfidf()
• step_zv()
• step_normalize()
• step_pca()

── Model ───────────────────────────────────────────────────────────────────────
Random Forest Model Specification (classification)

Main Arguments:
  trees = tune()

Computational engine: ranger 

Теперь ждать не так много, ведь данные стали менее разреженными.

plan(multisession, workers = 5)

tic()
set.seed(10032025)
rf_pca_tune <- rf_pca_wflow |> 
  tune_grid(
    resamples = folds, 
    grid = rf_grid,
    metrics = metric_set(accuracy),
    control = control_resamples(save_pred = TRUE, save_workflow = TRUE)
  )

rf_pca_tune

toc()
# 31.488 sec elapsed
plan(sequential)

Снова соединим воркфлоу.

wflow_set_final2 <- wflow_set_final |> 
  bind_rows(as_workflow_set(rf_pca = rf_pca_tune))

Видно, что серьезных ухудшений при снижении размерности не произошло, а производительность улучшилась значительно.

autoplot(wflow_set_final2, metric = "accuracy") + 
  theme_light() +
  theme(legend.position = "none") +
  geom_text(aes(y = (mean - 2*std_err), label = wflow_id), angle = 90, hjust = 1) +
  lims(y = c(-0.1, 1))

В следующем уроке попробуем улучшить результат.